;;;; -*- mode: lisp -*-
;;;;
;;;; $Id: xsd.lisp,v 1.26 2005/10/06 11:09:39 scaekenberghe Exp $
;;;;
;;;; A partial implementation of the XML Schema Definition standard
;;;;
;;;; Copyright (C) 2005 Sven Van Caekenberghe, Beta Nine BVBA. All Rights Reserved.
;;;;
;;;; You are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;;

(in-package :cl-soap)

;;; Model

(defclass xml-schema-definition ()
  ((target-namespace :accessor get-target-namespace :initarg :target-namespace :initform nil)
   (elements :accessor get-elements :initarg :elements :initform nil)))

(defmethod print-object ((object xml-schema-definition) out)
  (print-unreadable-object (object out :type t :identity t)
    (format out "target ~A, ~D elements"
	    (get-target-namespace object)
	    (length (get-elements object)))))

(defclass children-mixin ()
  ((children :accessor get-children :initarg :children :initform nil))
  (:documentation "Mixin for xsd elements with children."))

(defclass multiplicity-mixin ()
  ((min-occurs :accessor get-min-occurs :initarg :min-occurs :initform 1)
   (max-occurs :accessor get-max-occurs :initarg :max-occurs :initform 1))
  (:documentation "Mixin for xsd elements with minOccurs and maxOccurs attributes."))

(defclass nillable-multiplicity-mixin (multiplicity-mixin)
  ((nillable :accessor get-nillable :initarg :nillable :initform nil))
  (:documentation "Mixin for xsd elements with nillable attribute."))

;; schema elements occur with full information or with only a ref that is to be resolved
;; at use time
(defclass xml-schema-element (children-mixin nillable-multiplicity-mixin)
  ((name :accessor get-name :initarg :name :initform nil)
   (namespace :accessor get-namespace :initarg :namespace :initform "")
   (type :accessor get-type :initarg :type :initform nil))
  (:documentation "Representation of the ELEMENT element."))

(defmethod print-object ((object xml-schema-element) out)
  (print-unreadable-object (object out :type t :identity t)
    (prin1 (or (get-name object) "anonymous") out)))

(defclass xml-schema-element-proxy (xml-schema-element)
  ((ref :accessor get-ref :initarg :ref :initform nil)
   ;; locally set limits take precedence at resolution time
   (min-occurs-is-local :accessor get-min-occurs-is-local :initform nil)
   (max-occurs-is-local :accessor get-max-occurs-is-local :initform nil)
   (nillable-is-local   :accessor get-nillable-is-local :initform nil)
   ;; (uuh) FIXME: maybe we want to record the namespace context for ref in a slot too?
   ;; (could ease resolving)
   (resolved-status :accessor get-resolved-status :initform nil))
  (:documentation "Representation of an xml-schema-element that bears a ref attribute for late resolving."))

;; readers for base slots are specialized to check resolve status. We could also consider
;; a change-class method to the base class here to avoid repeated checks of resolved-status
(defmethod get-name ((o xml-schema-element-proxy))
  (if (get-resolved-status o) 
      (call-next-method)
      (error "Element ~A not yet resolved to base element." o)))

(defmethod get-type ((o xml-schema-element-proxy))
  (if (get-resolved-status o) 
      (call-next-method)
      (error "Element ~A not yet resolved to base element." o)))

(defmethod get-min-occurs ((o xml-schema-element-proxy))
  (if (or (get-min-occurs-is-local o)
	  (get-resolved-status o))
      (call-next-method)
      (error "Element ~A not yet resolved to base element." o)))

(defmethod get-max-occurs ((o xml-schema-element-proxy))
  (if (or (get-max-occurs-is-local o)
	  (get-resolved-status o)) 
      (call-next-method)
      (error "Element ~A not yet resolved to base element." o)))

(defmethod get-nillable ((o xml-schema-element-proxy))
  (if (or (get-nillable-is-local o)
	  (get-resolved-status o)) 
      (call-next-method)
      (error "Element ~A not yet resolved to base element." o)))

(defmethod print-object ((object xml-schema-element-proxy) out)
  (print-unreadable-object (object out :type t :identity t)
    (prin1 (or (get-ref object) "anonymous") out)
    (when (get-resolved-status object)
      (prin1 " (resolved)" out))))

(defmethod resolve-xml-schema-element-proxy ((o xml-schema-element-proxy) xml-schema-definitions)
  "Find the element referenced in the REF slot of O in the list of schema definitions XML-SCHEMA-DEFINITIONS.
Recursively resolves all unresolved proxy elements encountered on the way. Does nothing if O is already resolved. Does resolve children elements recursively."
  (unless (get-resolved-status o)
    (let* ((ref (get-ref o)))
      (multiple-value-bind (elt schema)
	  (loop :for schema-definition :in xml-schema-definitions
		:for element = (get-element-named schema-definition ref)
		:when element
		:return (values element schema-definition))
	(declare (ignore schema))
	;; avoid recursion on resolve status
	(setf (get-resolved-status o) elt)
	;; go down
	(dolist (child (get-children elt))
	  (when child (maybe-resolve-xsd-schema-element child xml-schema-definitions)))
	;; update our slots
	(setf (get-name o) (get-name elt)
	      (get-type o) (get-type elt)
	      (get-children o) (get-children elt))
	(unless (get-min-occurs-is-local o)
	  (setf (get-min-occurs o) (get-min-occurs elt)))
	(unless (get-max-occurs-is-local o)
	  (setf (get-max-occurs o) (get-max-occurs elt)))
	(unless (get-nillable-is-local o)
	  (setf (get-nillable o) (get-nillable elt)))))))

(defun maybe-resolve-xsd-schema-element (xml-schema-element xml-schema-definitions)
  "Guarantee that XML-SCHEMA-ELEMENT is fully resolved."
  (when (and (typep xml-schema-element 'xml-schema-element-proxy)
	     (not (get-resolved-status xml-schema-element)))
    (resolve-xml-schema-element-proxy xml-schema-element xml-schema-definitions)))

(defclass xsd-type (children-mixin)
  ((name :accessor get-name :initarg :name :initform nil)
   (namespace :accessor get-namespace :initarg :namespace :initform "")))

(defmethod print-object ((object xsd-type) out)
  (print-unreadable-object (object out :type t :identity t)
    (prin1 (or (get-name object) "anonymous") out)))

(defclass xsd-simple-type (xsd-type)
  ())

(defclass xsd-complex-type (xsd-type)
  ())

(defclass xsd-complex-content (children-mixin)
  ())

(defclass xsd-compositor (children-mixin multiplicity-mixin)
  ())

(defclass xsd-sequence (xsd-compositor)
  ())

(defclass xsd-choice (xsd-compositor)
  ())

(defclass xsd-all (xsd-compositor)
  ())

(defclass xsd-wildcard (xsd-type)
  ())

(defclass xsd-any (xsd-wildcard multiplicity-mixin)
  ((process-contents :accessor get-process-contents :initarg :process-contents :initform nil))
  (:documentation "Class representing the <any> element."))

(defclass xsd-restriction ()
  ((base :accessor get-base :initarg :base :initform nil)))

(defclass xsd-extension (children-mixin)
  ((base :accessor get-base :initarg :base :initform nil)))

(defmethod print-object ((object xsd-restriction) out)
  (print-unreadable-object (object out :type t :identity t)
    (prin1 (or (get-base object) "unknown") out)))

(defclass xsd-attribute (children-mixin)
  ((name :accessor get-name :initarg :name :initform nil)
   (namespace :accessor get-namespace :initarg :namespace :initform "")
   (type :accessor get-type :initarg :type :initform nil)
   (scope :accessor get-scope :initarg :scope :initform nil)
   (use :accessor get-use :initarg :use :initform nil)
   (default :accessor get-default :initarg :default :initform nil)
   (fixed :accessor get-fixed :initarg :fixed :initform nil))
  ;; (uuh) FIXME: missing support for ref attribute/proxy class
  (:documentation "Attribute declaration object."))

(defmethod print-object ((object xsd-attribute) out)
  (print-unreadable-object (object out :type t :identity t)
    (prin1 (or (get-name object) "anonymous") out)))

;;; Parsing

(defgeneric handle-lxml-schema-elements (mixin lxml target-namespace)
  (:documentation "Perform slot initialization for common attributes that are realized by mixin classes."))

(defmethod handle-lxml-schema-elements ((dummy T) lxml target-namespace)
  (declare (ignore lxml target-namespace))
  "Top-most `next method': do nothing")

(defmethod handle-lxml-schema-elements ((children-mixin children-mixin) lxml target-namespace)
  "Collect children of CHILDREN-MIXIN."
  (loop :for child :in (lxml-get-children lxml) 
        :do (push (lxml->schema-element child target-namespace) 
                  (get-children children-mixin)))
  (setf (get-children children-mixin) (nreverse (get-children children-mixin)))
  (call-next-method))

(defmethod handle-lxml-schema-elements ((multiplicity-mixin multiplicity-mixin) lxml target-namespace)
  "Collect multiplicity properties of MULTIPLICITY-MIXIN."
  (declare (ignorable target-namespace))
  (let* ((attributes (lxml-get-attributes lxml))
	 (min-occurs (getf attributes :|minOccurs|))
	 (max-occurs (getf attributes :|maxOccurs|)))
    (setf (get-min-occurs multiplicity-mixin)
	  (if min-occurs (parse-integer min-occurs) 1))
    (setf (get-max-occurs multiplicity-mixin)
	  (if max-occurs 
	      (if (equal max-occurs "unbounded")
		  :unbounded
		  (parse-integer max-occurs))
	      1))
    (call-next-method)))

(defmethod handle-lxml-schema-elements ((nillable-multiplicity-mixin nillable-multiplicity-mixin) lxml target-namespace)
  "Collect nillable-attribute information of NILLABLE-MULTIPLICITY-MIXIN."
  (declare (ignorable target-namespace))
  (let* ((attributes (lxml-get-attributes lxml))
	 (nillable (getf attributes :|nillable|)))
    (setf (get-nillable nillable-multiplicity-mixin)
	  (equal nillable "true"))
    (call-next-method)))

(defmethod handle-lxml-schema-elements ((xml-schema-element-proxy xml-schema-element-proxy) lxml target-namespace)
  "Proxy elements get special treatment because of local attributes that override the proxy."
  (declare (ignorable target-namespace))
  (call-next-method) ;; init all slots
  (let* ((attributes (lxml-get-attributes lxml)))
    (with-slots (nillable-is-local min-occurs-is-local max-occurs-is-local)
	xml-schema-element-proxy
      (setf nillable-is-local   (getf attributes :|nillable|)
	    min-occurs-is-local (getf attributes :|minOccurs|)
	    max-occurs-is-local	(getf attributes :|maxOccurs|)))))

(defun lxml->schema-element (lxml target-namespace)
  (let ((attributes (lxml-get-attributes lxml)))
    (case (lxml-get-tag lxml)
      (xsd:|element| 
       (let* ((name (getf attributes :|name|))
              (type (getf attributes :|type|))
	      (ref (getf attributes :|ref|))
              (xml-schema-element (apply #'make-instance 
					 (if ref 'xml-schema-element-proxy 'xml-schema-element)
					 :name name 
					 :namespace target-namespace
					 :type type
					 (if ref `(:ref ,ref) '()))))
         (handle-lxml-schema-elements xml-schema-element lxml target-namespace)
         xml-schema-element))
      (xsd:|simpleType|
       (let* ((name (getf attributes :|name|))
              (xsd-type (make-instance 'xsd-simple-type :name name
					 :namespace target-namespace)))
         (handle-lxml-schema-elements xsd-type lxml target-namespace)
         xsd-type))
      (xsd:|complexType|
       (let* ((name (getf attributes :|name|))
              (xsd-type (make-instance 'xsd-complex-type :name name
					 :namespace target-namespace)))
         (handle-lxml-schema-elements xsd-type lxml target-namespace)
         xsd-type))
      (xsd:|complexContent|
       (let ((xsd-complex-content (make-instance 'xsd-complex-content)))
         (handle-lxml-schema-elements xsd-complex-content lxml target-namespace)
         xsd-complex-content))
      (xsd:|restriction|
       (let* ((base (getf attributes :|base|))
              (xsd-restriction (make-instance 'xsd-restriction :base base)))
         xsd-restriction))
      (xsd:|extension|
       (let* ((base (getf attributes :|base|))
              (xsd-extension (make-instance 'xsd-extension :base base)))
         (handle-lxml-schema-elements xsd-extension lxml target-namespace)
         xsd-extension))
      (xsd:|sequence|
       (let* ((xsd-sequence (make-instance 'xsd-sequence)))
         (handle-lxml-schema-elements xsd-sequence lxml target-namespace)
         xsd-sequence))
      (xsd:|choice|
	   (let* ((xsd-choice (make-instance 'xsd-choice)))
	     (handle-lxml-schema-elements xsd-choice lxml target-namespace)
	     xsd-choice))
      (xsd:|any|
	   (let* ((process-contents (getf attributes :|processContents|))
		  (xsd-any (make-instance 'xsd-any
					  :process-contents (cond
							      ((equal process-contents "skip") :skip)
							      ((equal process-contents "lax")  :lax)
							      (T :strict)))))
	     (handle-lxml-schema-elements xsd-any lxml target-namespace)
	     xsd-any))
      (xsd:|attribute|
	   (let* ((name (getf attributes :|name|))
		  (type (getf attributes :|type|))
		  (use (getf attributes :|use|))
		  (default (getf attributes :|default|))
		  (fixed (getf attributes :|fixed|))
		  (xsd-attribute (make-instance 'xsd-attribute 
						:name name
						:type type
						:namespace target-namespace
						:use (cond ((equal use "required") :required)
							   ((equal use "prohinited") :prohibited)
							   (T :optional))
						;; :scope cannot be handled here -- needs to look up parent
						:default default
						:fixed fixed)))
	     (handle-lxml-schema-elements xsd-attribute lxml target-namespace)
	     xsd-attribute)))))

;; This implements a simple and incomplete solution to the include/import
;; elements (only inside the <types> <schema> elements).
;; At some point we should implement include and import elements
;; everywhere, and rewrite <schema> <import .../> <import .../> </schema>
;; in the parse-wsdl function to two schema elements with inlined #'import result
;; and not special-case this here
(defun lxml->imported-xml-schema-definition (lxml target-namespace &key import include)
  "Generate a schema definition from the import statement in LXML."
  (if (eql (lxml-get-tag lxml) 'xsd:|import|)
      (let* ((attributes (lxml-get-attributes lxml))
	     (target-namespace (or (getf attributes :|namespace|)
				   target-namespace))
	     (schema-location (getf attributes :|schemaLocation|))
	     (imported-schema-buffer (and import
					  (funcall import schema-location))))
	(if imported-schema-buffer
	    (with-input-from-string (in imported-schema-buffer)
	      (let ((imported-schemas (parse-xsd in :import import :include include)))
		;; (uuh) NOTE: This is not the full solution (relying on only one schema being returned)
		(when (< 1 (length imported-schemas))
		  (warn "Using only first schema returned from import of ~A." schema-location))
		(setf imported-schemas (first imported-schemas))
		;; correct the target namespace
		(setf (get-target-namespace imported-schemas)
		      (or target-namespace
			  ""))
		(format *debug-io* "Imported schema ~A as ~A using ~A~%" schema-location imported-schemas import)
		imported-schemas))
	    (progn
	      (format *debug-io* "Import of schemaLocation ~A skipped~A.~%" schema-location
		      (if import "" " (no :import function specified)"))
	      NIL)))
      (error "Expected a XSD <import> element")))

(defun lxml->included-xml-schema-definitions (lxml target-namespace &key import include)
  "Generate a list of elements for inclusion into a surrounding schema definition from the include statement in LXML."
  (if (eql (lxml-get-tag lxml) 'xsd:|include|)
      (let* ((attributes (lxml-get-attributes lxml))
	     (schema-location (getf attributes :|schemaLocation|))
	     (included-schema-buffer (and include
					  (funcall include schema-location))))
	(if included-schema-buffer
	    (with-input-from-string (in included-schema-buffer)
	      (let ((included-schemas (parse-xsd in :import import :include include)))
		;; (uuh) NOTE: This is not the full solution (relying on only one schema being returned)
		(when (< 1 (length included-schemas))
		  (warn "Using only first schema returned from include of ~A." schema-location))

		(format *debug-io* "Included schema ~A using ~A~%" schema-location include)
		(mapcar #'(lambda (elt) "Fixup namespace of the elements."
						(typecase elt
						  ((or xml-schema-element
						       xsd-type)
						   (setf (get-namespace elt) target-namespace)))
						elt) 
			(get-elements (first included-schemas)))))
	    (progn
	      (format *debug-io* "Inclusion of schemaLocation ~A skipped~A.~%" schema-location
		      (if include "" " (no :include function specified)"))
	      NIL)))
      (error "Expected a XSD <import> element")))

(defun lxml->schema-definitions (lxml &key import include)
  (if (eql (lxml-get-tag lxml) 'xsd:|schema|)
      (let* ((attributes (lxml-get-attributes lxml))
             (target-namespace (getf attributes :|targetNamespace|))
             (direct-xml-schema-definition (make-instance 
					    'xml-schema-definition
					    :target-namespace target-namespace))
	     imported-schema-definitions)
        (loop :for element :in (rest lxml) :do
	      (case (lxml-get-tag element)
		(xsd:|import|
		     (let ((imported-schema 
			    (lxml->imported-xml-schema-definition element target-namespace
								  :import import
								  :include include)))
		       (when imported-schema
			 (push imported-schema 
			       imported-schema-definitions))))
		(xsd:|include|
		     (let ((included-schema-part
			    (lxml->included-xml-schema-definitions element target-namespace
								   :import import
								   :include include)))
		       ;; included schema definitions get spliced into the direct definitions
		       (setf (get-elements direct-xml-schema-definition)
			     (nconc included-schema-part (get-elements direct-xml-schema-definition)))))
		(otherwise 
		 ;; direct elements 		 
		 (push (lxml->schema-element element target-namespace)
		       (get-elements direct-xml-schema-definition)))))
	(setf (get-elements direct-xml-schema-definition)
	      (nreverse (get-elements direct-xml-schema-definition)))
	;; (uuh) FIXME: attributes at schema level should have global scope set here...
	(if (get-elements direct-xml-schema-definition)
	    (cons direct-xml-schema-definition
		  imported-schema-definitions)
	    imported-schema-definitions))
      (error "Expected a XSD <schema> element")))

(defun parse-xsd (in &key import include)
  "Parse stream IN and return a list of xml-schema-definition objects.
Keyword arguments:
  :IMPORT can be used to define the handling of <import> elements.
          If NIL (the default) the element is ignored.
          A non-nil argument is assumed to be a function of 1 argument, the
          schemaLocation attribute of the element. If the function returns NIL,
          the element is ignored. Otherwise is must return a string which can
          be parsed to yield a xsd-schema-definition object.
          The functions wsdl-include-file and wsdl-include-url are suitable 
          arguments.
  :INCLUDE behaves like :IMPORT, but for the <include> element. "
  (let ((lxml (s-xml:parse-xml in)))
    (lxml->schema-definitions lxml :import import :include include)))

(defun parse-xsd-file (pathname &key import include)
  "Parse PATHNAME and return a list of xml-schema-definition objects.
Keyword arguments are as for PARSE-XSD."
  (with-open-file (in pathname)
    (parse-xsd in :import import :include include)))

(defun parse-xsd-url (url &key import include)
  "Parse URL and return a list of xml-schema-definition objects.
Keyword arguments are as for PARSE-XSD."
  (multiple-value-bind (buffer code)
      (do-http-request url)
    (if (eql code 200)
        (with-input-from-string (in buffer)
          (parse-xsd in :import import :include include))
      (error "Could not retrieve URL ~s, got a ~s code" url code))))

;;; Interpreting the XSD model

(defmethod get-element-named ((xml-schema-definition xml-schema-definition) element-name)
  (let ((elements (get-elements xml-schema-definition)))
    (find-item-named element-name elements)))

(defmethod get-type-in-context ((xsd-simple-type xsd-simple-type) elements)
  "For now: return the base type of the restriction child of the simple-type, if any"
  (declare (ignore elements))
  (let ((first-child (first (get-children xsd-simple-type))))
    (when (and first-child
               (typep first-child 'xsd-restriction))
      (get-base first-child))))

(defmethod get-type-in-context ((xsd-complex-type xsd-complex-type) elements)
  "A complex type cannot be reduced further"
  (declare (ignore elements))
  xsd-complex-type)

(defmethod get-type-in-context ((xml-schema-element xml-schema-element) elements)
  "Resolve the type of element to the most primitive one, in the context of elements"
  (let ((type (get-type xml-schema-element)))
    (cond (type
           (if (xsd-primitive-type-name-p type)
               type
             (get-type-in-context (find-item-named type elements) elements)))
          (t
           (let ((first-child (first (get-children xml-schema-element))))
             (when first-child
               (get-type-in-context first-child elements)))))))

(defmethod get-type-in-context ((xsd-sequence xsd-sequence) elements)
  "Sequences cannot be reduced further."
  (declare (ignore elements))
  xsd-sequence)

(defmethod get-element-type ((xml-schema-definition xml-schema-definition) element)
  "Resolve the type of element to the most primitive one, in the context of elements"
  (let ((element (if (stringp element) 
                     (find-item-named element (get-elements xml-schema-definition))
                   element)))
    (when element
      (get-type-in-context element (get-elements xml-schema-definition)))))

(defmethod get-members ((xsd-complex-type xsd-complex-type) (xml-schema-definition xml-schema-definition))
  "Return the list of members of xsd-complex-type, provided it is a sequence or a complex-content (for now)"
  (let ((first-child (first (get-children xsd-complex-type))))
    (cond ((and first-child (typep first-child 'xsd-sequence))
           (get-children first-child))
          ((and first-child (typep first-child 'xsd-complex-content))
           (get-members first-child xml-schema-definition)))))

(defmethod get-members ((xsd-compositor xsd-compositor) (xml-schema-definition xml-schema-definition))
  "Return the list of members of XSD-COMPOSITOR."
  (get-children xsd-compositor))

(defmethod get-members ((xsd-any xsd-any) (xml-schema-definition xml-schema-definition))
  "Return the list of members of xsd-sequence."
  (get-children xsd-any))

(defmethod get-members ((xsd-complex-content xsd-complex-content) (xml-schema-definition xml-schema-definition))
  "Return the list of members of xsd-complex-content, provided it is a base type sequence extension (for now)"
  (let ((first-child (first (get-children xsd-complex-content))))
    (when (and first-child (typep first-child 'xsd-extension))
      (let* ((base-type-name (get-base first-child))
             (base-type-element (get-element-named xml-schema-definition base-type-name))
             (base-members (get-members base-type-element xml-schema-definition))
             (first-child (first (get-children first-child))))
        (if (and first-child (typep first-child 'xsd-sequence))
            (append base-members (get-children first-child))
          base-members)))))

(defmethod get-multiplicity ((xml-schema-element multiplicity-mixin))
  (with-slots (min-occurs max-occurs)
      xml-schema-element
    (cond ((and (zerop min-occurs) (eql max-occurs 1)) :optional)
          ((and (eql min-occurs 1) (eql max-occurs 1)) :required)
          ((and (eql min-occurs 1) (eql max-occurs :unbounded)) :one-or-more)
          ((and (zerop min-occurs) (eql max-occurs :unbounded)) :zero-or-more)
          (t :complex))))

(defmethod is-optional-p ((xml-schema-element multiplicity-mixin))
  (zerop (get-min-occurs xml-schema-element)))

(defmethod is-plural-p ((xml-schema-element multiplicity-mixin))
  (eql (get-max-occurs xml-schema-element) :unbounded))

;;; Template Generation (converting the XSD model to something simpler ;-)

;; an XSD element template looks like this: 
;; ELT = ( <multiplicity> "namespace-uri" "element-name" [ (lambda () :primitive) | (lambda () ELT)* ] )
;; where <multiplicity> is 1, ?, + or * and :primitive is a XSD primitive type keyword
;; all element types are resolved into primitives or sequences of sub elements
;; elements without contents are also possible
;; element-name can be a name from the xsd package (e.g. xsd:|sequence| or xsd:|choice|)
;; The continuation-style tail is used to avoid infinite recursion on recursive types -- the template
;; user can eval it on demand
;; "namespace-uri" is the URI designating the namespace we should use to lookup element-name

(defmethod get-xsd-template-multiplicity ((xsd-type xsd-type))
  :xsd-type)

(defmethod get-xsd-template-multiplicity ((xml-schema-element multiplicity-mixin))
  (with-slots (min-occurs max-occurs)
      xml-schema-element
    (cond ((and (zerop min-occurs) (eql max-occurs 1)) '?)
          ((and (eql min-occurs 1) (eql max-occurs 1)) 1)
          ((and (eql min-occurs 1) (eql max-occurs :unbounded)) '+)
          ((and (zerop min-occurs) (eql max-occurs :unbounded)) '*)
          (t :complex))))

(defmethod get-xsd-template-multiplicity ((xml-schema-element nillable-multiplicity-mixin))
  (let ((pure-multiplicity (call-next-method)))
    (if (get-nillable xml-schema-element)
	(cond
	  ((eql pure-multiplicity 1) '?)
	  ((eql pure-multiplicity '+) '*)
	  (T pure-multiplicity))
	pure-multiplicity)))

(defgeneric generate-xsd-template (xml-schema-element schema-context all-xml-schema-definitions)
  (declare (optimize (debug 3) (speed 0)))
  (:documentation "Return xsd template for XML-SCHEMA-ELEMENT.
XML-SCHEMA-DEFINITIONS is a list of the definitions to search if xml-schema-element is a string.
If SCHEMA-CONTEXT is non-nil it will be used without searching the list."))

(defmethod generate-xsd-template ((xml-schema-element string)
				  schema-context
				  (all-xml-schema-definitions list))
  ;; string element and list of schemas: find schema object and schema to use
  (multiple-value-bind (element schema)
      (loop :for xml-schema-definition :in (if schema-context
					       (list schema-context)
					       all-xml-schema-definitions)
	    :for element = (get-element-named xml-schema-definition xml-schema-element)
	    :when element
	    :return (values element xml-schema-definition))
    
    (unless element (error "Cannot find element named ~s" xml-schema-element))
    (generate-xsd-template element schema all-xml-schema-definitions)))

(defmethod generate-xsd-template ((xml-schema-element xml-schema-element-proxy) 
				  (schema-context xml-schema-definition)
				  (all-xml-schema-definitions list))
  ;; a proxy element: resolve it ...
  (maybe-resolve-xsd-schema-element xml-schema-element all-xml-schema-definitions)
  ;; ... and handle it like a normal element
  (call-next-method))

(defmethod generate-xsd-template ((xml-schema-element xml-schema-element) 
				  (schema-context xml-schema-definition)
				  (all-xml-schema-definitions list))
  (let ((multiplicity (get-xsd-template-multiplicity xml-schema-element))
	(type (get-element-type schema-context xml-schema-element))
	(element-name (get-name xml-schema-element))
	(element-namespace (get-namespace xml-schema-element)))
    (unless (xsd-primitive-type-name-p type)
      ;; make sure simple types are resolved to their base primitive type
      (setf type (get-element-type schema-context type)))
    (if (xsd-primitive-type-name-p type)
	(let ((primitive-type-name (intern-xsd-type-name type)))
	  `(,multiplicity ,element-namespace ,element-name (lambda () ,primitive-type-name)))
	(let ((members (loop :for member :in (get-members type schema-context)
			     :collect (let ((member member)) ;; lexically close over loop var
					(lambda () (generate-xsd-template member schema-context all-xml-schema-definitions))))))
	  `(,multiplicity ,element-namespace ,element-name ,@members)))))

(defmethod generate-xsd-template ((xml-schema-element xsd-sequence) 
				  (schema-context xml-schema-definition)
				  (all-xml-schema-definitions list))
  ;; sequences at element level
  ;; (uuh) FIXME: element can be a sequence 
  ;;       (see "DateCreatedType" in efetch_nlmc.xsd )
  (let ((multiplicity (get-xsd-template-multiplicity xml-schema-element)))
    (let ((members (loop :for member :in (get-members xml-schema-element schema-context) 
			 :collect (let ((member member))
				    (lambda () (generate-xsd-template member schema-context all-xml-schema-definitions))))))
      `(,multiplicity ,+xsd2001-ns-uri+ "sequence" ,@members))))

(defmethod generate-xsd-template ((xml-schema-element xsd-choice) 
				  (schema-context xml-schema-definition)
				  (all-xml-schema-definitions list))
  (let ((multiplicity (get-xsd-template-multiplicity xml-schema-element)))
    (let ((members (loop :for member :in (get-members xml-schema-element schema-context) 
			 :collect (let ((member member))
				    (lambda () (generate-xsd-template member schema-context all-xml-schema-definitions))))))
      `(,multiplicity ,+xsd2001-ns-uri+ "choice" ,@members))))

(defmethod generate-xsd-template ((xml-schema-element xsd-any) 
				  (schema-context xml-schema-definition)
				  (all-xml-schema-definitions list))
  ;; wildcard element
  (let ((multiplicity (get-xsd-template-multiplicity xml-schema-element)))
    (let ((members (loop :for member :in (get-members xml-schema-element schema-context) 
			 :collect (let ((member member))
				    (lambda () (generate-xsd-template member schema-context all-xml-schema-definitions))))))
      `(,multiplicity ,+xsd2001-ns-uri+ "any" ,@members))))

(defun generate-xsd-templates (xml-schema-definition)
  (loop :for element :in (get-elements xml-schema-definition)
        :when (typep element 'xml-schema-element) ;; (uuh) CLARIFY: collect more here? Who uses this function anyway?
        :collect (generate-xsd-template element NIL (list xml-schema-definition))))

;;; Binding Templates (combining a template with an s-expr to generate an lxml list of tags)

(defun get-name-binding (name bindings)
  (let ((name-binding (member (actual-name name) bindings :test #'equal)))
    (if name-binding
        (values (second name-binding) t)
      (values nil nil))))

(defun bind-xsd-template-primitive (tag primitive-type value)
  (let ((primitive-value (lisp->xsd-primitive value primitive-type)))
    `(,tag ,primitive-value)))

(defun bind-xsd-template-members (tag members bindings schemas namespace)
  (let ((xsi-type (get-name-binding 'xsi::|type| bindings))
        (bound-members '()))
    (cond (xsi-type
           (let ((type-template (generate-xsd-template xsi-type NIL schemas)))
             (if (eql (first type-template) :xsd-type)
                 (loop :for member :in (rest (rest (rest type-template))) :do
		       (let ((member-binding (bind-xsd-template member bindings schemas namespace)))
			 (when member-binding 
			   (push member-binding bound-members))))
               (error "Could not resolve explicit (sub)type ~s" xsi-type))
             `((,tag xsi::|type| ,xsi-type) ,@(reduce #'append (nreverse bound-members)))))
          (t
           (loop :for member :in members :do
		 (let ((member-binding (bind-xsd-template member bindings schemas namespace)))
		   (when member-binding 
		     (push member-binding bound-members))))
           `(,tag ,@(reduce #'append (nreverse bound-members)))))))

(defun bind-xsd-template (template bindings schemas namespace)
  (destructuring-bind (multiplicity namespace-uri element-name &rest contents)
      template
    (setf contents (mapcar #'funcall contents)) ;; force evaluation of thunks
    (let ((tag (intern element-name (s-xml:get-package (s-xml:find-namespace namespace-uri)))))
      (multiple-value-bind (value boundp)
          (get-name-binding element-name bindings)
        (cond ((null contents) `(,tag))
              ((symbolp (first contents))
               (let ((primitive-type (first contents)))
                 (case multiplicity
                   ((1 ?) (if boundp
                              `(,(bind-xsd-template-primitive tag primitive-type value))
                            (when (eql multiplicity 1)
                              (error "Required element ~s not bound" element-name))))
                   ((+ *) (if (and boundp value)
                              (loop :for elt-value :in value
                                    :collect (bind-xsd-template-primitive tag primitive-type elt-value)) 
                            (when (eql multiplicity +)
                              (error "Required repeating element ~s not bound correctly" element-name)))))))
              (t
               (case multiplicity
                 ((1 ?) (if boundp
                            `(,(bind-xsd-template-members tag contents value schemas namespace))
                          (when (eql multiplicity 1)
                            (error "Required element ~s not bound" element-name))))
                 ((+ *) (if (and boundp value)
                            (loop :for elt-value :in value
                                  :collect (bind-xsd-template-members tag contents elt-value schemas namespace))
                          (when (eql multiplicity +)
                            (error "Required repeating element ~s not bound correctly" element-name)))))))))))
                
(defun bind-element (element bindings xml-schema-definitions namespace)
  (let ((template (generate-xsd-template element NIL xml-schema-definitions)))
    (reduce #'append (bind-xsd-template template bindings xml-schema-definitions namespace))))
                  
;;; Resolving Templates (combining a template with an lxml list to generate an s-expr)

(defun resolve-xsd-template-primitive (element-name primitive-type string)
  (let ((value (xsd-primitive->lisp string primitive-type)))
    `(,element-name ,value)))

(defun resolve-xsd-template-members (members lxml namespace)
  (let ((resolved-members '()))
    (loop :for member :in members :do
	  (let ((member-binding (resolve-xsd-template member lxml namespace)))
	    (when member-binding 
	      (push member-binding resolved-members))))
    (reduce #'append (nreverse resolved-members))))

(defun resolve-xsd-template (template lxml namespace)
  "Resolve TEMPLATE using LXML with default namespace NAMESPACE. Elements that are namespace-qualified in lxml are looked
up in the respective namespace package."
  (declare (optimize (debug 3) (speed 0)))
  (destructuring-bind (multiplicity namespace-uri element-name &rest contents)
      template
    (setf contents (mapcar #'funcall contents))	;; force evaluation of thunks
    (let* ((tag (intern element-name (s-xml:get-package (or (s-xml:find-namespace namespace-uri)
							    ;; (uuh) FIXME: is the following necessary?
							    namespace))))
	   (children (lxml-find-tags tag lxml)))
      (cond ((null contents) `(,element-name))
	    ((symbolp (first contents))
	     (let ((primitive-type (first contents)))
	       (case multiplicity
		 ((1 ?) (if children
			    (resolve-xsd-template-primitive element-name primitive-type 
							    (lxml-get-contents (first children)))
			    (when (eql multiplicity 1)
			      (error "Required element ~s not bound" element-name))))
		 ((+ *) (if children
			    (loop :for child :in children
				  :collect (resolve-xsd-template-primitive element-name primitive-type 
									   (lxml-get-contents child)))
			    (when (eql multiplicity +)
			      (error "Required repeating element ~s not bound correctly" element-name)))))))
	    (t
	     (case multiplicity
	       ((1 ?) (if children
			  `(,element-name ,(resolve-xsd-template-members contents (first children) namespace))
			  (when (eql multiplicity 1)
			    (error "Required element ~s not bound" element-name))))
	       ((+ *) (if children
			  `(,element-name
			    ,(loop :for child :in children
				   :collect (resolve-xsd-template-members contents child namespace)))
			  (when (eql multiplicity +)
			    (error "Required repeating element ~s not bound correctly" element-name))))))))))

(defun resolve-element (element lxml xml-schema-definitions namespace)
  (let ((template (generate-xsd-template element NIL xml-schema-definitions)))
    (resolve-xsd-template template lxml namespace)))

;;; Describing XSD (print the 'sexpr' format with multiplicity indicators using in input/output binding)

(defun indent (n &optional (stream *standard-output*))
  (format stream "~&")
  (loop :repeat n 
        :do (write-char #\space stream) (write-char #\space stream)))

(defun describe-xsd-template-members (members &optional (stream *standard-output*) (level 0) (elements-seen-stack NIL))
  (loop :for member :in members :do
        (describe-xsd-template member stream (1+ level) elements-seen-stack)))

(defun describe-xsd-template (template &optional (stream *standard-output*) (level 0) (elements-seen-stack NIL))
  (destructuring-bind (multiplicity namespace-uri element-name &rest contents)
      template
    (setf contents (mapcar #'funcall contents))
    (let ((namespace-prefix (s-xml:get-prefix (s-xml:find-namespace namespace-uri))))
      (cond ((null contents) 
	     (indent level)
	     (format stream "(~a:~s) ~a" namespace-prefix element-name multiplicity))
	    ((symbolp (first contents))
	     (let ((primitive-type (first contents)))
	       (case multiplicity
		 ((1 ?) 
		  (indent level)
		  (format stream "(~a:~s ~s) ~a " namespace-prefix element-name primitive-type multiplicity))
		 ((+ *) 
		  (indent level)
		  (format stream "(~a:~s (~s) ~a )" namespace-prefix element-name primitive-type multiplicity)))))
	    (t
	     (case multiplicity
	       ((1 ?) 
		(indent level)
		(format stream "(~a:~a" namespace-prefix element-name)
		(if (find element-name elements-seen-stack :test #'(lambda (x y)
								     (and (stringp x)
									  (stringp y)
									  (string= x y))))
		    (format stream " -- see above --")
		    (describe-xsd-template-members contents stream level 
						   (if (stringp element-name)
						       (cons element-name elements-seen-stack)
						       elements-seen-stack)))
		(format stream ") ~a " multiplicity))
	       ((+ *) 
		(indent level)
		(format stream "(~a:~a (" namespace-prefix element-name)
		(if (find element-name elements-seen-stack :test #'(lambda (x y)
								     (and (stringp x)
									  (stringp y)
									  (string= x y))))
		    (format stream " -- see above --")
		    (describe-xsd-template-members contents stream level 
						   (cons element-name elements-seen-stack)))
		(format stream ") ~a )" multiplicity))))))))

(defun describe-xsd-element (element xml-schema-definitions &optional (stream *standard-output*) (level 0))
  (let ((template (generate-xsd-template element NIL xml-schema-definitions)))
    (describe-xsd-template template stream level))
  (format stream "~&")
  (values))

(defun describe-xsd (xml-schema-definition &optional (stream *standard-output*))
  "Print a high-level description of the top-level elements in xml-schema-definition"
  (format stream "XML Schema Definition with target-namespace URI ~s~%" 
          (get-target-namespace xml-schema-definition))
  (loop :for element :in (get-elements xml-schema-definition) :do
        (when (typep element 'xml-schema-element)
          (describe-xsd-element element xml-schema-definition stream 1)))
  (format stream "~&")
  (values))

;;; Primitive Types/Values (types are identified :keywords)

(defconstant +known-primitive-type-names+
  '("string" 
    "normalizedString" "token"
    "Name" "QName" "NCName" "anyURI"
    "integer"
    "positiveInteger" "negativeInteger" "nonPositiveInteger" "nonNegativeInteger"
    "long" "unsignedLong" "int" "unsignedInt" "short" "unsignedShort"
    "byte" "decimal"
    "float" "double"
    "boolean"
    "duration" "date" "time" "dateTime"
    "base64Binary" "hexBinary"))

(defun xsd-primitive-type-name-p (name)
  (and (stringp name)
       (member (actual-name name) +known-primitive-type-names+ :test #'string-equal)))

(defun intern-xsd-type-name (name)
  (intern (string-upcase (actual-name name)) :keyword))

;;; Date, Time and DateTime conversions

(defvar *xsd-timezone* nil
  "Timezone used when encoding/decoding xsd times. Like for decode-universal-time this must be a rational multiple of 1/3600 between -24 (inclusive) and 24 (inclusive).")

(defun ut (&optional year month date (hours 0) (minutes 0) (seconds 0))
  "Convenience function to create Common Lisp universal times"
  (when (or (null year) (null month) (null date))
    (multiple-value-bind (second minute hour current-date current-month current-year)
        (if *xsd-timezone*
            (decode-universal-time (get-universal-time) *xsd-timezone*)
          (decode-universal-time (get-universal-time)))
      (declare (ignore second minute hour))
      (unless year (setf year current-year))
      (unless month (setf month current-month))
      (unless date (setf date current-date))))
  (if *xsd-timezone*
      (encode-universal-time seconds minutes hours date month year *xsd-timezone*)
    (encode-universal-time seconds minutes hours date month year)))

(defun lisp->xsd-datetime (universal-time)
  "1999-05-31T13:20:00.000-05:00"
  (multiple-value-bind (second minute hour date month year day daylight-p timezone)
      (if *xsd-timezone*
          (decode-universal-time universal-time *xsd-timezone*)
        (decode-universal-time universal-time))
    (declare (ignore day daylight-p))
    (let ((sign (if (minusp timezone) #\- #\+))
          (timezone-hour (floor (* (abs timezone) 60) 60))
          (timezone-minute (rem (* (abs timezone) 60) 60)))
      (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d.000~c~2,'0d:~2,'0d" 
              year month date hour minute second sign timezone-hour timezone-minute))))

(defun xsd-datetime->lisp (string)
  "1999-05-31T13:20:00.000-05:00"
  (let* ((contains-millis (position #\. string))
         (contains-timezone (or (position #\: string :start 18) (position #\Z string)))
         (year (parse-integer string :start 0 :end 4))
         (month (parse-integer string :start 5 :end 7))
         (date (parse-integer string :start 8 :end 10))
         (hour (parse-integer string :start 11 :end 13))
         (minute (parse-integer string :start 14 :end 16))
         (second (parse-integer string :start 17 :end 19))
         timezone-sign
         timezone-hour
         timezone-minute)
    (when contains-timezone
      (if (position #\Z string)
          (setf timezone-sign 1 
                timezone-hour 0
                timezone-minute 0)
        (if contains-millis
            (setf timezone-sign (ecase (char string 23) (#\- -1) (#\+ +1))
                  timezone-hour (parse-integer string :start 24 :end 26)
                  timezone-minute (parse-integer string :start 27 :end 29))
          (setf timezone-sign (ecase (char string 19) (#\- -1) (#\+ +1))
                timezone-hour (parse-integer string :start 20 :end 22)
                timezone-minute (parse-integer string :start 23 :end 25)))))
    (if (or *xsd-timezone* contains-timezone)
        (encode-universal-time second minute hour date month year 
                               (if contains-timezone 
                                   (* timezone-sign (+ timezone-hour (/ timezone-minute 60)))
                                 *xsd-timezone*))
      (encode-universal-time second minute hour date month year))))

(defun lisp->xsd-date (universal-time)
  "1999-05-31"
  (multiple-value-bind (second minute hour date month year)
      (if *xsd-timezone*
          (decode-universal-time universal-time *xsd-timezone*)
        (decode-universal-time universal-time))
    (declare (ignore second minute hour))
    (format nil "~4,'0d-~2,'0d-~2,'0d" year month date)))

(defun xsd-date->lisp (string)
  "1999-05-31"
  (let ((year (parse-integer string :start 0 :end 4))
        (month (parse-integer string :start 5 :end 7))
        (date (parse-integer string :start 8 :end 10)))
    (if *xsd-timezone*
        (encode-universal-time 0 0 0 date month year *xsd-timezone*)
      (encode-universal-time 0 0 0 date month year))))

(defun lisp->xsd-time (universal-time)
  "13:20:00.000-05:00"
  (multiple-value-bind (second minute hour date month year day daylight-p timezone)
      (if *xsd-timezone*
          (decode-universal-time universal-time *xsd-timezone*)
        (decode-universal-time universal-time))
    (declare (ignore year month date day daylight-p))
    (let ((sign (if (minusp timezone) #\- #\+))
          (timezone-hour (floor (* (abs timezone) 60) 60))
          (timezone-minute (rem (* (abs timezone) 60) 60)))
      (format nil "~2,'0d:~2,'0d:~2,'0d.000~c~2,'0d:~2,'0d" 
              hour minute second sign timezone-hour timezone-minute))))

(defun xsd-time->lisp (string)
  "13:20:00.000-05:00"
  (let* ((contains-millis (position #\. string))
         (contains-timezone (position #\: string :start 7))
         (hour (parse-integer string :start 0 :end 2))
         (minute (parse-integer string :start 3 :end 5))
         (second (parse-integer string :start 6 :end 8))
         timezone-sign
         timezone-hour
         timezone-minute)
    (when contains-timezone
      (if contains-millis
          (setf timezone-sign (ecase (char string 12) (#\- -1) (#\+ +1))
                timezone-hour (parse-integer string :start 13 :end 15)
                timezone-minute (parse-integer string :start 16 :end 18))
        (setf timezone-sign (ecase (char string 8) (#\- -1) (#\+ +1))
              timezone-hour (parse-integer string :start 9 :end 11)
              timezone-minute (parse-integer string :start 12 :end 14))))
    (if (or *xsd-timezone* contains-timezone)
        (encode-universal-time second minute hour 1 1 0
                               (if contains-timezone 
                                   (* timezone-sign (+ timezone-hour (/ timezone-minute 60)))
                                 *xsd-timezone*))
      (encode-universal-time second minute hour 1 1 0))))

;;; Primitive Types/Values Conversions

(defun xsd-primitive->lisp (value type)
  "Convert the XSD string value to a Common Lisp value, interpreting it as type"
  (ecase type
    ((:string :normalizedString :token) 
     (if (null value) "" value))
    ((:Name :QName :NCName :anyURI) 
     (if (null value) "" value))
    ((:integer 
      :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger
      :long :unsignedLong :int :unsignedInt :short :unsignedShort 
      :byte :decimal) 
     (parse-integer value))
    (:float
     (coerce (read-from-string value) 'float))
    (:double
     (coerce (read-from-string value) 'double-float))
    (:boolean
     (cond ((string-equal value "true") t)
           ((string-equal value "false") nil)
           (t (= (parse-integer value) 1))))
    (:duration value)
    (:date (xsd-date->lisp value))
    (:time (xsd-time->lisp value))
    (:dateTime (xsd-datetime->lisp value))
    ((:base64Binary :hexBinary) 
     (error "~a not yet supported as primitive type" type))))

(defun lisp->xsd-primitive (value type)
  "Convert the Common Lisp value to a XSD string value, interpreting it as type" 
  (ecase type
    ((:string :normalizedString :token) 
     value)
    ((:Name :QName :NCName :anyURI) 
     value)
    ((:integer 
      :positiveInteger :negativeInteger :nonPositiveInteger :nonNegativeInteger
      :long :unsignedLong :int :unsignedInt :short :unsignedShort 
      :byte :decimal) 
     (princ-to-string value))
    (:float
     (princ-to-string value))
    (:double
     (princ-to-string value))
    (:boolean 
     (if value "true" "false"))
    (:duration value)
    (:date (lisp->xsd-date value))
    (:time (lisp->xsd-time value))
    (:dateTime (lisp->xsd-datetime value))
    ((:base64Binary :hexBinary) 
     (error "~a not yet supported as primitive type" type))))

;;;; eof
